home *** CD-ROM | disk | FTP | other *** search
/ Technotools / Technotools (Chestnut CD-ROM)(1993).ISO / lang_bas / mices / popmouse.sub < prev   
Text File  |  1988-04-16  |  4KB  |  167 lines
  1.   SUB POPMOUSE(HEADER$,CHOICES%,SET%,ITEMS$(2),FRAME%,FORE%,BACK%,HFORE%,HBACK%,QUADRANT$,SHADOW%,CHOICE%) STATIC
  2.   DEFINT A-Z
  3.   DIM SCRN(2000)
  4.  
  5.   ' Determine width of window from length of items
  6.  
  7.   WINDLEN=LEN(HEADER$)
  8.   FOR J = 1 TO CHOICES
  9.     IF LEN(ITEMS$(SET,J)) > WINDLEN THEN WINDLEN=LEN(ITEMS$(SET,J))
  10.   NEXT J
  11.  
  12.   ' If quadrant is in row:col format, extract row and column
  13.  
  14.   IF INSTR(QUADRANT$,":") <> 0 THEN GOSUB Getord: GOTO Go1
  15.  
  16.   ' Determine position based on quadrant parameter and size of menu
  17.  
  18.   QUADRANT=VAL(QUADRANT$)
  19.   IF QUADRANT > 4 OR QUADRANT < 0 THEN QUADRANT=0
  20.   IF QUADRANT = 0 THEN CROW=12: CCOL=40 ELSE ON QUADRANT GOSUB Quad1,Quad2,Quad3,Quad4
  21.   ULR=CROW-((CHOICES+2)/2-.5)
  22.   ULC=CCOL-((WINDLEN/2)-.5)
  23.   LRR=ULR+CHOICES+1
  24.   LRC=ULC+WINDLEN-1
  25.  
  26. Go1:    'Create window for menu
  27.  
  28.   WHERE=VARPTR(SCRN(0))
  29.   CALL SCRSAVE(WHERE)
  30.  
  31.   CALL MAKEWINDOW(ULC,ULR,LRC,LRR,LABEL$,FRAME,0,FORE,BACK,0)
  32.  
  33.   ' Place header in window
  34.  
  35.   TEMPHDR$=SPACE$(WINDLEN)
  36.   IF LEN(HEADER$) <> WINDLEN THEN GOSUB Puthdr
  37.  
  38.   CALL CALCATTR(HFORE,HBACK,ATTR)
  39.   ROW=ULR: COL=ULC
  40.   CALL XQPRINTD(HEADER$,ROW,COL,ATTR,0)
  41.   CALL CALCATTR(FORE,BACK,ATTR)
  42.   ROW=ULR+1: COL=ULC
  43.   DAT$=STRING$(WINDLEN,205)
  44.   CALL XQPRINTD(DAT$,ROW,COL,ATTR,0)
  45.  
  46.   GOSUB Make.Menu
  47.  
  48.   ' Set current choice to menu item #1 and enter loop
  49.  
  50.   CLICK=0: CHOICE=1: CALL CLRKBD: GOSUB Turn.On: CALL MMCHECK(MOUSE)
  51.   IF MOUSE <> 0 THEN
  52.     MOUSE=-1: LFTCOL=8*COL-8: TOPROW=8*ROW-8
  53.     RGTCOL=8*LRC-8: BOTROW=8*LRR-8
  54.     CALL MMSETRANGE(LFTCOL,TOPROW,RGTCOL,BOTROW)
  55.   END IF
  56.  
  57.   GOSUB Turn.Off: ' Update position of selection marker
  58.  
  59. Lope:
  60.   IF MOUSE THEN GOSUB LopeX: IF CLICK GOTO Done
  61.   GOSUB Press  ' Get keypress
  62.   IF KP$ = CHR$(13) OR KP$ = CHR$(27) GOTO Done
  63.   GOTO Lope
  64.  
  65.   ' Check for left or right mouse button clicked
  66.  
  67. Lopex:
  68.   CALL MMBUTTON(LFT,RGT)
  69.   IF RGT <> 0 THEN CHOICE=0: CLICK=-1: RETURN
  70.   CALL MMGETLOC(MOUSECOL,MOUSEROW)
  71.   IF LFT <> 0 THEN CHOICE=MOUSEROW\8-ULR: CLICK=-1: RETURN
  72.   IF CHOICE = MOUSEROW\8-ULR THEN RETURN
  73.   OLD=CHOICE: CHOICE=MOUSEROW\8-ULR: GOSUB Turn.Off: RETURN
  74.  
  75.   ' Check for keypress and sound error if not up arrow, down arrow, or return
  76.  
  77. Press:
  78.   KP$=INKEY$
  79.   IF KP$ = "" THEN RETURN
  80.   IF KP$ = CHR$(13) THEN RETURN
  81.   IF KP$ = CHR$(27) THEN CHOICE=0: RETURN
  82.  
  83.   ' Sound error if not up arrow, down arrow, home, end, page up, page down, or return
  84.  
  85.   IF LEN(KP$) = 1 THEN SOUND 1000,1: SOUND 1500,2: SOUND 500,1: RETURN
  86.  
  87.   ' Process down arrow keypress
  88.  
  89.   IF ASC(RIGHT$(KP$,1)) = 80 THEN
  90.     OLD=CHOICE: CHOICE=CHOICE+1
  91.     IF CHOICE > CHOICES THEN CHOICE=1
  92.     GOSUB Turn.Off: RETURN
  93.   END IF
  94.  
  95.   ' Process up arrow keypress
  96.  
  97.   IF ASC(RIGHT$(KP$,1)) = 72 THEN
  98.     OLD=CHOICE: CHOICE=CHOICE-1
  99.     IF CHOICE < 1 THEN CHOICE=CHOICES
  100.     GOSUB Turn.Off: RETURN
  101.   END IF
  102.  
  103.   ' Process error
  104.  
  105.   SOUND 1000,1: SOUND 1500,2: SOUND 500,1: RETURN
  106.  
  107. Turn.Off:  'Turn off present selection
  108.   IF MOUSE THEN CALL MMCURSOROFF
  109.   CALL CALCATTR(FORE,BACK,ATTR)
  110.   ROW=(ULR+1+OLD): COL=ULC
  111.   DAT$=ITEMS$(SET,OLD)
  112.   CALL XQPRINTD(DAT$,ROW,COL,ATTR,0)
  113.  
  114. Turn.On:  'Turn on new selection
  115.   CALL CALCATTR(BACK,FORE,ATTR)
  116.   ROW=(ULR+1+CHOICE): COL=ULC
  117.   DAT$=ITEMS$(SET,CHOICE)
  118.   CALL XQPRINTD(DAT$,ROW,COL,ATTR,0)
  119.   IF MOUSE THEN CALL MMSETLOC(LFTCOL,8*(CHOICE+ULR)): CALL MMCURSORON
  120.   RETURN
  121.  
  122. Make.Menu:  'Place menu items in window
  123.   FOR J = 1 TO CHOICES
  124.     CALL CALCATTR(FORE,BACK,ATTR)
  125.     ROW=(ULR+1+J): COL=ULC
  126.     DAT$=ITEMS$(SET,J)
  127.     CALL XQPRINTD(DAT$,ROW,COL,ATTR,0)
  128.   NEXT J
  129.   RETURN
  130.  
  131. Quad1:
  132.   CROW=7: CCOL=20
  133.   RETURN
  134.  
  135. Quad2:
  136.   CROW=7: CCOL=60
  137.   RETURN
  138.  
  139. Quad3:
  140.   CROW=18: CCOL=60
  141.   RETURN
  142.  
  143. Quad4:
  144.   CROW=18: CCOL=20
  145.   RETURN
  146.  
  147. Getord:
  148.  
  149.   ULR=VAL(LEFT$(QUADRANT$,2))+1
  150.   ULC=VAL(RIGHT$(QUADRANT$,2))
  151.   LRR=ULR+CHOICES+1
  152.   LRC=ULC+WINDLEN-1
  153.   RETURN
  154.  
  155. Puthdr:
  156.  
  157.   PAD=(WINDLEN/2)-(LEN(HEADER$)/2)-.5
  158.   MID$(TEMPHDR$,PAD+1,LEN(HEADER$))=HEADER$
  159.   HEADER$=TEMPHDR$
  160.   RETURN
  161.  
  162. Done:
  163.   IF MOUSE THEN CALL MMCURSOROFF
  164.   CALL SCRREST(WHERE)
  165.  
  166.   END SUB
  167.